perm filename NOTBMS.F4[NEW,LCS]22 blob sn#496793 filedate 1980-02-09 generic text, type T, neo UTF8
00100	C*****  SUBRS NOTES, MISMCH  ***********
00200	
00300		SUBROUTINE NOTES
00400		COMMON/SCM/V(78),I,LCNT,STAFF,LIST(200),REND
00500		1 /SCX/JALPHA(30),JX,RA,JZ,IRHY,RB,KA,KB,IZ
00600		1 /XRN/RN(1)
00700		1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG,
00800		1 JXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA /ALF/CLF,JQX,D,
00900		1 KQ,JG,X,ACC,STMDR,Y,LL,RZ,RC,INP(61) /POS/POS1,POS2,PSFB
01000		1 /FRMT/F78F(1),FA1(1),FA5(1),ASK 
01100		1 /RINP/R(10,85),RPOS(2,50) /RMOD/RMODE2,SET4,IBEAM,
01200		1 NOSET,STEM,STUP,NTC,PS2,RAM,JSTEM,ITB,POSB
01300	CX	1 NOSET,STEM,STUP,NTC,PS2,RAM,RDD,ITB,POSB
01400	CCC	DATA ACMV/2.3/
01500		RMODE=0
01600		JSTEM=1000
01700	C JSTEM IS FOR BEAMS ROUTINE.
01800		IF(RMODE2.GE.500)RMODE=RMODE2
01900	C  RMODE2≥500 IS FOR USER-ADDED NOTE AND REST ROUTINE (SUBR EXTRA)
02000	CP	POS1=0
02100	CP	POS2=200
02200		STFLG=0
02300	8	KN=0
02400		IRHY=0
02500	C  IZ=# OF ITEMS FROM SCANR*******
02600		IZ=I-1
02700	C  LIMIT OF 100 ITEMS***** 4/74 *****
02800		CLF=0
02900		KCLF=0
03000		JCLF=0
03100	C  DEFAULT IS ALWAYS TREBLE CLEF
03200	
03300		IF(POS2.NE.0)GO TO 71
03400		POS2=200
03500	71	K=IZ+1
03600		DO 70 KQ=1,IZ
03700		X=V(KQ)
03800		IF(X.GE.0)GO TO 70
03900		IF(-X.LT.2000)K=K-1
04000	C TO GET THE RIGHT ITEM COUNT WITH CHORDS, ETC.
04100	70	CONTINUE
04200	
04300		D=(POS2-POS1)/K
04400	C   D WILL SPACE ALL ITEMS EVENLY FOR NOW
04500	
04600		STEM=-1
04700	C   K=COUNTER FOR USEFUL ITEMS (OMITS CLEFS)
04800		K=1
04900		KQ=1
05000	C   LOOPS TO 7333 
05100	7	JG=-1
05200		X=V(KQ)
05300	C notes =  1xyz.0   x=accidental, yz=note num.,  negative=chord note
05400	C rest  =  2xyz.0   z=0=ordinary, =1=invis., =2=whole, =3=repeat bar
05500	C                   =4=down, =5=up, -2xyz=num. of meas. rest
05600	C clefs =  3xyz.0   z=0=treble, =1=bass, =2=alto, =3=tenor, neg.=invis.
05650	C use TRE,BAS,ALT,TEN for clefs with no change to note levels.(4,5,6,7)
05700	C bars  =  4xyz.0   z=num. of staves up, neg.=dbl.bar
05800	C ksig  = 17xyz.0   z=num. of accis.,  pos.=#, neg.=b
05900	C meter = 18xyz.n   xy=top num, zn=bottom num	(DONE IN SCMSS)
06000	C stem  =  5xyz.0   YZ=10=stem up,  =20=stem down
06100	C staff =  5xyz.0   z=0=return to norm., =1=lower stf., =2=upper stf.
06200	
06300		IF(X)GO TO 27
06400	C NEXT SORTS OUT ORDER OF CHORD
06500		RZ=V(KQ+1)
06600		IF(RZ.GT.0)GO TO 27
06700		IF(ABS(RZ).GE.2000)GO TO 27
06800	C  SKIPS NON-NOTES  
06900	327	RZ=AMOD(X,100.0)
07000	57	LL=KQ
07100		Y=0
07200		RA=RZ
07300	37	LL=LL+1
07400		STMDR=RA
07500		RA=-V(LL)
07600		IF(RA)GO TO 27
07700		IF(RA.GE.4000)GO TO 27
07800	C  EXITS WITH NON-NOTES OR NON-CHORD NOTES.  (ABOVE FOR DBL BAR)
07900		RA=AMOD(RA,100.0)
08000	C  GETS RID OF ACCI. FOR NOW
08100		IF(RA.GE.99)GO TO 27
08200		IF(Y)127,97,67
08300	C Y IS STEM DIRECTION.  -1=DOWN, 1=UP
08400	97	Y=RA-STMDR
08500		GO TO 37
08600	67	IF(RA.LT.RZ)V(LL)=V(LL)-7
08700	C TRAP FOR NOTE IN WRONG OCT. (CONFUSES STEM DIRECTION.)
08800		IF(RA.GE.STMDR)GO TO 37
08900	227	CALL EXCH(V(LL),V(LL-1))
09000	C NOW START OVER AGAIN
09100		GO TO 57
09200	127	IF(RA.GT.RZ)V(LL)=V(LL)+7
09300		IF(STMDR.GT.RA)GO TO 37
09400		GO TO 227
09500	27	R4=0
09600		R5=0
09700		R6=0
09800		R8=0
09900		DO 89 LL=2,10
10000	89	R(LL,K)=0
10100	C   TO CLEAR END OF ITEM
10200		KODE=ABS(X)/1000
10300		IF(X.LT.0.AND.KODE.NE.2)GO TO 86
10400	C  JUMP IF A CHORD NOTE, CLEF OR BAR OR METER
10500		IF(KODE.LE.2)IRHY=IRHY+1
10600	C   ADDS A RHYTHMIC UNIT
10700	C  TO CLEAR LAST PARAMS IN SOME ITEMS LATER
10800	86	GO TO (21,22,23,24,25),KODE
10900		IF(KODE.EQ.17)GO TO 1700
11000	C  NEXT IS FOR METERS
11100		L=(X-18000.)/10
11200		R5=L
11300	C   GETS TOP NUM OF METER
11400		R6=AMOD(X,10.0)*10.0+.01
11500		GO TO 843
11600	
11700	23  	CLF=ABS(X)-3000.
11720		IF(CLF.LT.4)GO TO 223
11740	C NOW CLEFS THAT DON'T INFLUENCE NOTE LEVELS. (4,5,6,7)
11760		CLF=CLF-4
11780		GO TO 323
11800	223	JCLF=CLF
11900		IF(X.LT.0)GO TO 871
12000	C  IS THE CLEF INVISIBLE?
12100	323	R5=CLF
12200		IF(K.EQ.1)GO TO 123
12300		IF(KCLF.OR.R(1,K-1).NE.4)R4=R4+100
12400	C  IF NOT 1ST ITEM (AND 1ST IS NOT BAR) THEN MINI CLEF.
12500	123	KCLF=-1
12600		GO TO 843
12700	
12800	25	Y=X-5000
12900		IF(Y.LT.10)GO TO 250
13000	C  NEXT FOR STEM UP, DOWN
13100	C DOWN = 20 (5020), UP=10 (5010)
13200		STEM=Y
13300		IF(JSTEM.EQ.1000)JSTEM=K
13400	C SAVE POINTER TO FIRST SPECIFIED STEM DIRECTION. (FOR BEAMS)
13500		GO TO 871
13600	250	STFLG=Y
13700	C  STAFF ABOVE=2, BELOW=1, RESET=0
13800		GO TO 871
13900	
14000	24	R4=ABS(X)-4000
14100		CALL NOZERO(R4)
14200		IF(X)R4=R4+1300
14300	C  NEG =DBL BAR.  (heavy bar to right)
14400		GO TO 843
14500	
14600	1700	R5=ABS(X)-17000.
14700	C KEY SIGS    NEG=FLATS
14800		IF(X)R5=-R5
14900		R6=CLF
15000		GO TO 843
15100	
15200	22	Y=ABS(X)-2000
15300		IF(X)GO TO 831
15400		IF(Y.EQ.0)GO TO 843
15500	C  ORDINARY REST=0
15600		IF(Y.LT.4)GO TO 882
15700	C  REST UP=5, DOWN=4
15800		R4=6
15900		IF(Y.EQ.4)R4=-R4
16000		GO TO 843
16100	
16200	882	IF(Y.EQ.1)GO TO 885
16300		IF(Y.EQ.2)GO TO 886
16400	C NEXT FOR CENTERED REPEAT SIGN
16500		R8=-5
16600		GO TO 843
16700	
16800	885	R6=-2
16900	C ↑↑ FOR INVIS. REST  (FIRST YOU SEE IT, THEN YOU DON'T.)
17000		GO TO 843
17100	
17200	886	R8=-1
17300	C ↑ FOR WHOLE REST (ANY RHYTHM)
17400		GO TO 843
17500	
17600	831	R8=Y
17700	C  NUMS OF BARS REST
17800		GO TO 843
17900	
18000	21	R(10,K)=STFLG
18100		IF(X.GT.0)GO TO 210
18200		X=-X
18300		R8=-1
18400	C  CHORD NOTE
18500		JG=0 
18600	210	LL=X-1000
18700	C  NOTES
18800		L=LL/100
18900	C  THE ACCI.
19000		R5=L
19100		N=MOD(LL,100)-1
19200	C  THE NOTE NUM.
19300		L=N/7
19400	C OCT. NUM HERE IS 1 .GT. THAN THAT TYPED.  (OCT. 0 IS POSSIBLE NOW.)
19500		N=MOD(N,7)+1
19600	C  ABSOLUTE NOTE NUM.
19700		KA=JCLF*12
19800	C  THIS WILL ADJUST FOR CLEF NUM.
19900		IF(JCLF.GE.2)KA=JCLF*2+2
20000		R4=(L-4)*7+KA+N
20100		STMDR=10.
20200		IF(R4.GE.7)STMDR=20.
20300		IF(STEM.LE.0)GO TO 26
20400		STMDR=STEM
20500	C  SHORTEN STEMS WHEN TURNED TO NON-STANDARD DIRECTION.
20600	CCC NO NO NO -- THIS USED ELSEWHERE.	R8=-1
20700	C  FOR STEM DIRECTIONS - 'B' AND HIGHER HAVE STEMS DOWN.
20800	26	IF(JG.GE.0)GO TO 6
20900	C  NEXT LENGTHENS STEMS FOR VERY HIGH OR VERY LOW NOTES.
21000		IF(STMDR.EQ.20)GO TO 16
21100	C NEXT FOR STEM UP
21200		IF(R4.LT.0)R8=-R4
21300	C  STEMS OF VERY HIGH OR VERY LOW NOTES WILL ALWAYS TOUCH MIDDLE LINE
21400		GO TO 3133
21500	16	IF(R4.GT.14)R8=R4-14
21600	C SEE 'BEAMS' AT 143 FOR SIMILAR FEATURE
21700		GO TO 3133
21800	6	L=K-1
21900		IF(R(5,L).GE.10.)MX=L
22000	C  MX=1ST NOTE OF CHRD
22100		STMDR=0
22200		L=K-MX
22300		IF(R4.LT.R(4,MX))L=-L
22400		R(7,MX)=L
22500	C L+=STEM UP, L-=STEM DOWN ... USED AT END OF NOTES.
22600		X=ABS(R(4,MX)-R4)-1.
22700	C  EXTENDS THE STEM!
22800	C  AFTER 1ST NOTE, ORDER MAY BE SCRAMBLED IN CHORDS.  STEM OK.
22900		IF(X.LT.1.)X=1.
23000		IF(R(8,MX).LT.X)R(8,MX)=X
23100	3133	R5=R5+STMDR
23200	
23300	843	R(4,K)=R4
23400		R(5,K)=R5
23500		R(6,K)=R6
23600		R(8,K)=R8
23700	CS	R(2,K)=STAFF
23800		IF(JG)KN=KN+1
23900		R(3,K)=KN*D+POS1
24000		R(1,K)=KODE
24100	87	K=K+1
24200	871	KQ=KQ+1
24300		IF(KQ.LE.IZ)GO TO 7
24400	
24500		IZ=K-1
24600	C  IZ IS NOW REALLY THE NUMBER OF ITEMS TO BE PROCESSED
24700	C  NEXT ADJUSTS PLACEMENT OF ACCIDENTALS AND 2NDS.
24800		K=1
24900	1	RX=R(7,K)
25000		IF(RX.EQ.0)GO TO 2
25100		IF(R(1,K).EQ.2.)GO TO 2
25200	C  JUMP IF NO CHRD COMING
25300		IF(RX.GT.0)GO TO 3
25400	C  JUMP IF STEM IS UP
25500		RA=R(5,K)
25600		IF(RA.LT.10)GO TO 277
25700		IF(RA.LT.20.)R(5,K)=RA+10.
25800	C  PUTS STEM DOWN IF IT WASN'T
25900	277	L=K-RX
26000	C  RX=TOTAL(-1) NOTES IN CHORD
26100		R(7,K)=0
26200	4	RA=R(4,K)
26300		RC=0
26400	C  INTERVAL TO PREVIOUS NOTE
26500	C  CHECK ON USE OF N ELSEWHERE
26600		N=K+1
26700		IF(K.LT.L)RC=RA-R(4,N)
26800	C  INTERVAL TO NEXT NOTE
26900		IF(RC+R(6,K).EQ.1.)R(6,N)=20
27000	C  PUSHES NOTE TO LEFT 
27100	5	K=N
27200		IF(K.GT.L)GO TO 220
27300		GO TO 4
27400	
27500	3	DO 30 M=2,IZ
27600		L=M-1
27700		IF(R(4,M)-R(4,L)+R(6,L).NE.1.)GO TO 30
27800		IF(R(3,M).NE.R(3,L))GO TO 30
27900		R(6,M)=10
28000		R(6,L)=30
28100	30	CONTINUE
28200	C  TO HELP DOTTED NOTES.
28300	C  MOVES NOTE TO RIGHT OF STEM WHEN 2ND.
28400	C  THE STEM IS UP
28500		RA=R(5,K)
28600		IF(RA.GE.20.)R(5,K)=RA-10.
28700	C  PUTS STEM UP IF IT WASN'T
28800		R(7,K)=0
28900		K=1+K+RX
29000	220	CALL ACSHFT(RX)
29100	C  L=K-1=END OF CHORD;  L-ABS(RX)=START OF CHORD; +RX=↑  -RX=↓
29200		GO TO 222
29300	
29400	2	K=K+1
29500	222	IF(K.LE.IZ)GO TO 1
29600		R(1,K)=0
29700		END
29800	
29900	
30000	
30100		SUBROUTINE MISMCH(RA,Y)
30200		CALL TYPCRLF
30300		CALL TYPSTR('**** MISMATCH WITH SPACING STAFF ****')
30400		CALL TYPFLT(RA)
30500		CALL TYPCRLF
30600		CALL TYPFLT(Y)
30700		CALL TYPSTR(' QUARTERS IN THIS LINE.')
30800		CALL TYPCRLF
30900		END